Исходный текст

Option Explicit
Call AddFileToObj(ThisObject)

'==============================================================================
' Добавить в состав объекта выбранные пользователем файлы
'==============================================================================
Sub AddFileToObj(Obj)

        Dim SelFileDlg, FName, FShortName, FDef, FExtension, NewFile, StrMsg,_
                 RetVal, StrErr, flag, count

        ' Открываем диалог выбора файла
        Set SelFileDlg = ThisApplication.Dialogs.FileDlg
        SelFileDlg.Filter = "Все файлы (*.*)|*.*||"
        RetVal = SelFileDlg.Show
        
        'Если пользователь отменил диалог, выйти из подпрограммы
        If RetVal <> TRUE Then Exit Sub    
        
        Set NewFile = Nothing
        count = 0
        
        'Для каждого выбранного файла проверить, может ли он быть добавлен к объекту
        For Each FName In SelFileDlg.FileNames
                
                ' Получаем расширение выбранного файла
                FExtension = "*." & Right(FName, Len(Fname) - InStrRev(FName, "."))
                flag = FALSE
                
                'Проверить, есть ли такое расширение у типов файлов, определенных в типе объекта
                For Each FDef In Obj.ObjectDef.FileDefs
                        
                        ' Если строка расширения найдена, добавим файл к объекту
                        If InStr(FDef.Extensions, FExtension) <> 0 Then
                                flag = TRUE 'файл разрешен для добавления (расширение найдено)

                                'Создать новый пустой объект в файловом составе
                                Set NewFile = Obj.Files.Create(FDef.SysName)
                                'Заметим: вызов метода Create приводит к генерации событий File_BeforeAdd, File_Added,
                                'метода CheckIn - к генерации File_BeforeCheckIn, File_CheckedIn
                                
                                'Теперь надо загрузить файл в файловое хранилище. Если файл с таким именем 
                                'уже существует, будет выдана ошибка.
                                
                                On Error Resume Next 'отключить перехват ошибок
                                
                                'попытка загрузить файл
                                NewFile.CheckIn FName
                                
                                'Если ошибка была, сообщим что файл с таким именем уже существует
                                If Err<>0 Then
                                        FShortName = Right(FName, Len(Fname) - InStrRev(FName, "\"))
                                        MsgBox "Файл """ & FShortName & """ уже есть в составе объекта.", vbInformation
                                        
                                        'удалить пустой файл
                                        NewFile.Erase 
                                        'Генерируются события File_BeforeErase, File_Erased!
                                Else
                                        StrMsg = StrMsg & Chr(13) & FName
                                        count = count+1
                                End If
                                
                                On Error Goto 0 'Восстановить перехват ошибок
                                Exit For
                        End If
                Next 'For Each FDef...
                
                'Добавить расширение файла в сообщение об ошибке
                If flag <> TRUE Then StrErr = StrErr & Chr(13) & FExtension 

        Next 'For Each FName...
        
        
        'Сообщить результаты
        If StrMsg <> "" Then 
                MsgBox "К объекту были добавлены следущие файлы:" & StrMsg, vbInformation
        End If
        
        If StrErr <> "" Then
                MsgBox "Файлы следующих типов не разрешены для добавления к объекту:" &_
                StrErr, vbInformation
        End If
        
        
        MsgBox count & " файлов добавлено к объекту.", vbInformation
End Sub
'==============================================================================